home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
cmpnew
/
cmpmain.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
20KB
|
508 lines
;;; CMPMAIN Compiler main program.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;; **** Caution ****
;;; This file is machine/OS dependant.
;;; *****************
(in-package 'compiler)
(export '(*compile-print* *compile-verbose*))
(defvar *compiler-in-use* nil)
(defvar *compiler-input*)
(defvar *compiler-output1*)
(defvar *compiler-output2*)
(defvar *compiler-output-data*)
(defvar *error-p* nil)
(defvar *compile-print* nil)
(defvar *compile-verbose* t)
#+(and bsd (not seq))(pushnew 'buggy-cc *features*)
(defmacro get-output-pathname (file ext)
`(make-pathname :directory (or (and (not (null ,file))
(not (eq ,file t))
(pathname-directory ,file))
dir)
:name (or (and (not (null ,file))
(not (eq ,file t))
(pathname-name ,file))
name)
:type ,ext))
#+unix
(defun safe-system (string)
(let ((result (system string)))
(unless (zerop result)
(cerror "Continues anyway."
"(SYSTEM ~S) returned a non-zero value ~D."
string
result)
(setq *error-p* t))
(values result)))
(defun compile-file1 (input-pathname
&key (output-file input-pathname)
#+aosvs (fasl-file t)
#+unix (o-file t)
(c-file nil)
(h-file nil)
(data-file nil)
#+aosvs (ob-file nil)
(system-p nil)
(load nil)
&aux (*standard-output* *standard-output*)
(*error-output* *error-output*)
(*compiler-in-use* *compiler-in-use*)
(*package* *package*)
(*error-count* 0))
(cond (*compiler-in-use*
(format t "~&The compiler was called recursively.~%~
Cannot compile ~a."
(namestring (merge-pathnames input-pathname #".lsp")))
(setq *error-p* t)
(return-from compile-file1 (values)))
(t (setq *error-p* nil)
(setq *compiler-in-use* t)))
(unless (probe-file (merge-pathnames input-pathname #".lsp"))
(format t "~&The source file ~a is not found.~%"
(namestring (merge-pathnames input-pathname #".lsp")))
(setq *error-p* t)
(return-from compile-file1 (values)))
(when *compile-verbose*
(format t "~&Compiling ~a."
(namestring (merge-pathnames input-pathname #".lsp"))))
(let* ((eof (cons nil nil))
(dir (or (and (not (null output-file))
(pathname-directory output-file))
(pathname-directory input-pathname)))
(name (or (and (not (null output-file))
(pathname-name output-file))
(pathname-name input-pathname)))
#+aosvs (fasl-pathname (get-output-pathname fasl-file "fasl"))
#+unix (o-pathname (get-output-pathname o-file "o"))
(c-pathname (get-output-pathname c-file "c"))
#+buggy-cc
(s-pathname (merge-pathnames ".s" (pathname-name c-pathname)))
(h-pathname (get-output-pathname h-file "h"))
(data-pathname (get-output-pathname data-file "data"))
#+aosvs (ob-pathname (get-output-pathname ob-file "ob"))
)
(init-env)
(when (probe-file #+unix "./cmpinit.lsp" #+aosvs "=cmpinit.lsp")
(load #+unix "./cmpinit.lsp" #+aosvs "=cmpinit.lsp"
:verbose *compile-verbose*))
(with-open-file (*compiler-output-data*
#+unix data-pathname #+aosvs fasl-pathname
:direction :output)
(wt-data-begin)
(with-open-file
(*compiler-input* (merge-pathnames input-pathname #".lsp"))
(let* ((rtb *readtable*)
(prev (and (eq (get-macro-character #\# rtb)
(get-macro-character
#\# (si:standard-readtable)))
(get-dispatch-macro-character #\# #\, rtb))))
(if (and prev (eq prev (get-dispatch-macro-character
#\# #\, (si:standard-readtable))))
(set-dispatch-macro-character #\# #\,
'si:sharp-comma-reader-for-compiler rtb)
(setq prev nil))
(unwind-protect
(do ((form (read *compiler-input* nil eof)
(read *compiler-input* nil eof)))
((eq form eof))
(t1expr form))
(when prev (set-dispatch-macro-character #\# #\, prev rtb)))))
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname system-p
(if system-p
#-aosvs (pathname-name input-pathname)
#+aosvs (string-downcase
(pathname-name input-pathname))
"code")))
(wt-data-end)
) ;;; *compiler-output-data* closed.
(init-env)
(if (zerop *error-count*)
#+aosvs
(progn
(when *compile-verbose* (format t "~&End of Pass 2. "))
(when data-file
(with-open-file (in fasl-pathname)
(with-open-file (out data-pathname :direction :output)
(si:copy-stream in out))))
(cond ((or fasl-file ob-file)
(compiler-cc c-pathname ob-pathname)
(cond ((probe-file ob-pathname)
(when fasl-file
(compiler-build ob-pathname fasl-pathname)
(when load (load fasl-pathname)))
(unless ob-file (delete-file ob-pathname))
(when *compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a."
(namestring (merge-pathnames
input-pathname #".lsp")))))
(t (format t "~&Your C compiler failed to compile the intermediate file.~%")
(setq *error-p* t))))
(*compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a."
(namestring (merge-pathnames
input-pathname #".lsp")))))
(unless c-file (delete-file c-pathname))
(unless h-file (delete-file h-pathname))
(unless fasl-file (delete-file fasl-pathname)))
#+unix
(progn
(when *compile-verbose* (format t "~&End of Pass 2. "))
(cond (o-file
(compiler-cc c-pathname o-pathname #+buggy-cc s-pathname)
(cond ((probe-file o-pathname)
(compiler-build o-pathname data-pathname)
(when load (load o-pathname))
#+buggy-cc (delete-file s-pathname)
(when *compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a."
(namestring (merge-pathnames
input-pathname #".lsp")))))
(t #+buggy-cc (when (probe-file s-pathname)
(delete-file s-pathname))
(format t "~&Your C compiler failed to compile the intermediate file.~%")
(setq *error-p* t))))
(*compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a."
(namestring (merge-pathnames
input-pathname #".lsp")))))
(unless c-file (delete-file c-pathname))
(unless h-file (delete-file h-pathname))
(unless data-file (delete-file data-pathname)))
(progn
(when (probe-file c-pathname) (delete-file c-pathname))
(when (probe-file h-pathname) (delete-file h-pathname))
#+aosvs
(when (probe-file fasl-pathname) (delete-file fasl-pathname))
#+unix
(when (probe-file data-pathname) (delete-file data-pathname))
(format t "~&No FASL generated.~%")
(setq *error-p* t))
))
(values))
(defun compile1 (name &optional (def nil supplied-p)
&aux form gazonk-name
#+aosvs fasl-pathname
#+unix data-pathname
(*compiler-in-use* *compiler-in-use*)
(*standard-output* *standard-output*)
(*error-output* *error-output*)
(*package* *package*)
(*compile-print* nil)
(*error-count* 0))
(unless (symbolp name) (error "~s is not a symbol." name))
(cond (*compiler-in-use*
(format t "~&The compiler was called recursively.~%~
Cannot compile ~s." name)
(setq *error-p* t)
(return-from compile1))
(t (setq *error-p* nil)
(setq *compiler-in-use* t)))
(cond ((and supplied-p (not (null def)))
(unless (and (consp def) (eq (car def) 'lambda))
(error "~s is invalid lambda expression." def))
(setq form (if name
`(defun ,name ,@(cdr def))
`(set 'gazonk #',def))))
((and (consp (setq def (symbol-function name)))
(eq (car def) 'lambda-block)
(consp (cdr def)))
(setq form `(defun ,name ,@(cddr def))))
(t (error "No lambda expression is assigned to the symbol ~s." name)))
(dotimes (n 1000
(progn
(format t "~&The name space for GAZONK files exhausted.~%~
Delete one of your GAZONK*** files before compiling ~s." name)
(setq *error-p* t)
(return-from compile1 (values))))
(setq gazonk-name (format nil "gazonk~3,'0d" n))
#+aosvs
(setq fasl-pathname (make-pathname :name gazonk-name :type "fasl"))
#+unix
(setq data-pathname (make-pathname :name gazonk-name :type "data"))
(unless (probe-file #+aosvs fasl-pathname
#+unix data-pathname)
(return)))
(let ((c-pathname (make-pathname :name gazonk-name :type "c"))
#+buggy-cc
(s-pathname (make-pathname :name gazonk-name :type "s"))
(h-pathname (make-pathname :name gazonk-name :type "h"))
#+unix (o-pathname (make-pathname :name gazonk-name :type "o"))
#+aosvs (ob-pathname (make-pathname :name gazonk-name :type "ob")))
(init-env)
(with-open-file (*compiler-output-data*
#+unix data-pathname #+aosvs fasl-pathname
:direction :output)
(wt-data-begin)
(t1expr form)
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname nil "code"))
(wt-data-end)
) ;;; *compiler-output-data* closed.
(init-env)
(if (zerop *error-count*)
#+aosvs
(progn
(when *compile-verbose* (format t "~&End of Pass 2. "))
(compiler-cc c-pathname ob-pathname)
(delete-file c-pathname)
(delete-file h-pathname)
(cond ((probe-file ob-pathname)
(compiler-build ob-pathname fasl-pathname)
(delete-file ob-pathname)
(load fasl-pathname :verbose nil)
(when *compile-verbose* (print-compiler-info))
(delete-file fasl-pathname)
(or name (symbol-value 'gazonk)))
(t (delete-file fasl-pathname)
(format t "~&Your C compiler failed to compile the intermediate code for ~s.~%" name)
(setq *error-p* t)
name)))
#+unix
(progn
(when *compile-verbose* (format t "~&End of Pass 2. "))
(compiler-cc c-pathname o-pathname #+buggy-cc s-pathname)
(delete-file c-pathname)
(delete-file h-pathname)
#+buggy-cc (when (probe-file s-pathname) (delete-file s-pathname))
(cond ((probe-file o-pathname)
(compiler-build o-pathname data-pathname)
(load o-pathname :verbose nil)
(when *compile-verbose* (print-compiler-info))
(delete-file o-pathname)
(delete-file data-pathname)
(or name (symbol-value 'gazonk)))
(t (delete-file data-pathname)
(format t "~&Your C compiler failed to compile the intermediate code for ~s.~%" name)
(setq *error-p* t)
name)))
(progn
(when (probe-file c-pathname) (delete-file c-pathname))
(when (probe-file h-pathname) (delete-file h-pathname))
#+aosvs
(when (probe-file fasl-pathname) (delete-file fasl-pathname))
#+unix
(when (probe-file data-pathname) (delete-file data-pathname))
(format t "~&Failed to compile ~s.~%" name)
(setq *error-p* t)
name))))
(defvar *disassembled-form* '(defun gazonk ()))
(defun disassemble1 (&optional (thing nil)
&key (h-file nil) (data-file nil)
&aux def
(*compiler-in-use* *compiler-in-use*))
(cond (*compiler-in-use*
(format t "~&The compiler was called recursively.~%~
Cannot disassemble ~a." thing)
(setq *error-p* t)
(return-from disassemble1))
(t (setq *error-p* nil)
(setq *compiler-in-use* t)))
(cond ((null thing))
((symbolp thing)
(setq def (symbol-function thing))
(cond ((macro-function thing)
(error
"Associated with the symbol ~s is a macro, not a function."
thing))
((not (and (consp def)
(eq (car def) 'lambda-block)
(consp (cdr def))))
(error "The function object ~s cannot be disassembled." def))
(t (setq *disassembled-form* `(defun ,thing ,@(cddr def))))))
((and (consp thing) (eq (car thing) 'lambda))
(setq *disassembled-form* `(defun gazonk ,@(cdr thing))))
(t (setq *disassembled-form* thing)))
(let ((*compiler-output1* *standard-output*)
(*compiler-output2* (if h-file
(open h-file :direction :output)
(make-broadcast-stream)))
(*compiler-output-data* (if data-file
(open data-file :direction :output)
(make-broadcast-stream)))
(*error-count* 0))
(unwind-protect
(progn
(init-env)
(wt-data-begin)
(t1expr *disassembled-form*)
(cond ((zerop *error-count*)
(catch *cmperr-tag* (ctop-write "code")))
(t (setq *error-p* t)))
(wt-data-end)
(init-env)
)
(when h-file (close *compiler-output2*))
(when data-file (close *compiler-output-data*))))
(values)
)
(defun compiler-pass2 (c-pathname h-pathname system-p init-name)
(with-open-file (*compiler-output1* c-pathname :direction :output)
(with-open-file (*compiler-output2* h-pathname :direction :output)
(when system-p
(wt-nl1 "/* (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. */")
(wt-h "/* (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. */"))
(wt-nl1 "#include <cmpinclude.h>")
(wt-nl1 "#include \""
#-aosvs (namestring h-pathname)
#+aosvs (string-downcase (namestring h-pathname))
"\"")
(catch *cmperr-tag* (ctop-write init-name))
(terpri *compiler-output1*)
(terpri *compiler-output2*))))
#+aosvs
(defun compiler-cc (c-pathname ob-pathname)
(process "cc.pr" ; or ":usr:dgc:cc.pr"
(format nil "cc/opt=~d/noextl/e=@null/o=~a,~a"
*speed* (namestring ob-pathname) (namestring c-pathname))
:block t :ioc t)
(when (string/= (princ (last-termination-message)) "") (terpri)))
#+unix
(defun compiler-cc (c-pathname o-pathname #+buggy-cc s-pathname)
#+e15
(let ((C (namestring
(make-pathname
:directory (pathname-directory c-pathname)
:name (pathname-name c-pathname)
:type "C")))
(H (namestring
(make-pathname
:directory (pathname-directory h-pathname)
:name (pathname-name h-pathname)
:type "H"))))
(system (format nil "mv ~A ~A" (namestring c-pathname) C))
(system (format nil "mv ~A ~A" (namestring h-pathname) H))
(system (format nil "~Atrans < ~A > ~A"
(namestring si:*system-directory*) C (namestring c-pathname)))
(system (format nil "~Atrans < ~A > ~A"
(namestring si:*system-directory*) H (namestring h-pathname)))
(delete-file C)
(delete-file H))
(safe-system
(format nil
#-(or system-v e15 dgux)
#+buggy-cc
#+vax"cc ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A"
#-vax"cc ~@[~*-O ~]-S -I. -w ~a ; as -J -o ~A ~A"
#-buggy-cc "cc ~@[~*-O ~]-c -I. -w ~a"
#+(or system-v e15 dgux) "cc ~@[~*-O ~]-c -I. ~a 2> /dev/null"
(if (or (= *speed* 2) (= *speed* 3)) t nil)
(namestring c-pathname)
#+buggy-cc (namestring o-pathname)
#+buggy-cc (namestring s-pathname)
))
#-buggy-cc
(let ((cname (pathname-name c-pathname))
(odir (pathname-directory o-pathname))
(oname (pathname-name o-pathname)))
(unless (and (equalp (truename "./")
(truename (make-pathname :directory odir)))
(equal cname oname))
(safe-system
(format nil "mv ~A.o ~A" cname (namestring o-pathname))))))
#+aosvs
(defun compiler-build (ob-pathname fasl-pathname)
(process
(namestring
(merge-pathnames si:*system-directory* "build_fasl.pr"))
(si:string-concatenate
"build_fasl," (namestring fasl-pathname) ","
(namestring ob-pathname))
:block t :ioc t)
(when (string/= (last-termination-message) "")
(setq *error-p* t)
(princ (last-termination-message))
(terpri)))
#+unix
(defun compiler-build (o-pathname data-pathname)
#+(and system-v (not e15))
(safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A"
(namestring o-pathname)))
(when (probe-file o-pathname)
(safe-system (format nil #-dgux "cat ~A >> ~A"
#+dgux "~Abuild_o ~A ~A"
#+dgux (namestring si:*system-directory*)
(namestring data-pathname)
(namestring o-pathname)))))
(defun print-compiler-info ()
(format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%"
(cond ((null *compiler-check-args*) 0)
((null *safe-compile*) 1)
((null *compiler-push-events*) 2)
(t 3))
*safe-compile* *space* *speed*))